home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / rcs-31.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  52.3 KB  |  1,044 lines  |  [TEXT/CCL2]
  1. ;;; RCS.LISP (Simple Revision Control System)
  2. ;;; Version 3.1, July '94 
  3. ;;; Functions for managing the editing of project code by multiple people.
  4. ;;; Hacked by David Neves - neves@ils.nwu.edu
  5. ;;;
  6. (in-package :ccl)
  7.  
  8. #|
  9.  Changes:
  10.  allender/neves
  11.          (7/94)    Misc. minor changes for multiple projects.
  12.  neves   (6/94)    Fix bug in backup when saving newly created files -- files not on the server.
  13.  neves             A backup directory is now available.  Unlocking a file will have the older version
  14.                    placed in a backup directory.
  15.  neves &
  16.  allender(5/94)    Multiple projects are now handled
  17.  neves  (1/94)     Add *files-to-copy* so that the user can specify files and directories
  18.                    to copy. see documentation near the defvar.
  19.  neves  (12/93)    Close an editor file that is the same name as a file you are locking.
  20.                    When updating a directory delete any fasl files corresponding to
  21.                    .lisp files that are copied over.
  22.  neves  (11/93)    Change all :overwrites to :supersedes in copy/rename-file.
  23.                    Have lock-project-file remember directory the file came from so
  24.                    that the next lock-project-file will start at that directory.
  25.                    Change the setq of *files-not-to-copy* in init-rcs to pushnews so that
  26.                    the user can initialize *files-not-to-copy* in rcs-init.lisp.
  27.                    Adding Jeff's change below generated an error with a comment that
  28.                    didn't have a comment character in front of it.  Fixed.
  29.  neves  (11/93)    Add Jeff Lind's changes to lock files on the server.   Have rcs
  30.                    check for a ccl:rcs-init.lisp file to load.  rcs-init.lisp can
  31.                    be used to set defparameters below without having to recompile
  32.                    and reload this software.
  33.                    Also put a dialog front end to
  34.                    list of files/directories to not copy on an update.
  35.  neves  (11/93)    Put in locking protocol so that it is not possible for two people
  36.                    to lock or unlock files at the same time.  This eliminates possible
  37.                    inconsistancies to the file that has data on locked files.  
  38.                    Thanks Steve Feist for the suggestion on how to do this.
  39.  neves  (11/93)    Allow none copying of subdirectories in project tree by putting the
  40.                    directory name in *files-not-to-copy*.  Update will ask the user to
  41.                    specify directories they don't want to copy.
  42.                    Put in a menu choice to get
  43.                    the comments about changes for the currently displayed project file.
  44.                    Delete minor change to get-string-from-user. It didn't work. 
  45.  neves  (10/93)    Minor change to get-string-from-user.
  46.  neves  (7/27/93)  Changes to make logical pathname stuff work for a user on the server
  47.  jona   (2/2/93)   Wrap menu call to copy-directory in a eval-enqueue.
  48.  neves  (1/15/93)  As per Kemi's suggestion, have init-rcs put a call to itself in
  49.                    *lisp-startup-functions*.
  50.  neves  (1/14/93)  use *home-directory-o* to store logical pathname of home directory.
  51.  jona   (1/6/93)   balloon help and code to better display log file.
  52.  neves  (12/10/92) copy-directory now prints out name of file copied. Don't ask if non-text
  53.                    files should be edited when locking them.
  54.  neves  (11/12/92) Have button to Forget files be labeled as Forget rather than Unlock.
  55.  neves  (10/29/92) Check to see if *server-volume* is mounted.  When locking, don't copy
  56.                    the file over if you already have the most recent version.
  57.                    Other misc changes.
  58.  neves  (10/16/92) Add *files-not-to-copy* to prevent RCS bookkeeping files from being
  59.                    copied to a users local disk.  Other misc changes.
  60.  neves  (10/15/92) Add help and viewing of log file
  61.  neves  (10/15/92) Lock file before copying to the local disk.
  62.  neves  (10/14/92) Fix pathname bugs for released MCL 2.0, add copy-directory function
  63.  neves  (1/21)     Make a variable to hold folder of server volume on server machine
  64.  neves  (1/7/92)   Server now has a separate working directory.
  65.  neves  (12/23/91) Updated to MACL 2.0 Beta
  66.  
  67.  =========================================================================================
  68.  Documentation:
  69.    On any large project there is a danger of 2 people editing the same file at the same time.
  70.  Most likely one person's changes will be lost.  This software allows someone to "lock" a
  71.  file so that no one else can edit it.  When the user is finished editing the file they
  72.  can "unlock" the file so that others can edit it.
  73.    Project files are kept on a central server.  Locking a file copies that file to the user's
  74.  local hard disk and stores the file name in a list of locked files on the central server. 
  75.  When the user unlocks the file, the file is copied back to the server and the file name
  76.  is removed from the list of locked files.
  77.    The project directory on the server may be hierarchical. Files copied from it 
  78.  will be put in the same relative position on the user hard disk.  
  79.  For example, the file server:foo:bar might be copied to
  80.  user:foo:bar.  "foo" is a subfolder where bar is located.
  81.  =========================================================================================
  82.  
  83.  User choices from the "lockfile" menu:
  84.    - Lock a file.  This brings up a dialog so that the user can choose a file to lock.  If
  85.      the file is already locked then the user gets an error message.  Locking a file
  86.      copies the file from the server to the local hard disk.  Then the name of the locked
  87.      file is stored in a special file ("locked-file-list") on the server.
  88.    - Unlock a file and copy to server.  This brings up a dialog with all your locked files.  
  89.      Select 1 or more files (with shift-click) to unlock.  The files are copied back to the 
  90.      server and their names are deleted from "locked-file-list".
  91.    - Unlock a file, but don't copy to server.  This is like the choice above but the files
  92.      are not copied to the server.  Useful when the user changes his/her mind about making
  93.      the changes permanent.
  94.    - Copy a newly created file to the server.  The user has just created a file on his/her
  95.      hard disk.  To move it to the server choose this.
  96.    - Update - copy server directory to local disk.  Updates all files.
  97.    - Show all locked files.  Show a list of all the locked files, along with who locked them.
  98.  
  99.  Hardware needed:
  100.    Each user needs a Macintosh with access to an Appleshare network.
  101.    You need a server machine that can be mounted from other Macs.
  102.  
  103.  Software needed:
  104.    System 7.0 (or greater) & MACL 2.0 (or greater)
  105.  
  106.  To install:
  107.     Simply load this file after changing the defparameters below.  
  108.     The LockFile menu choice will install itself.
  109.  
  110.  To do:
  111.     - from Kemi : use apple events to be able to edit other than text files
  112.     - It would be nice if this software mounted the server volume.  I don't know how to do this.
  113.       HOWEVER if the users create an alias on the desktop with the same same as the server volume
  114.       this software will automatically open it up (a probe-file will do it).
  115.     - Change log file to allow multi-line comments
  116.  
  117.  Known bugs:
  118.  - Someone can keep a lock on the lock list file too long by not responding to the
  119.  dialog that asks if they want to lock a project file that is older than one on their
  120.  hard disk.  This only happens during lock-project-file.
  121.  - If the client and server clocks are more than 15 minutes out of phase then rcs will not do the
  122.  right thing on updates and locking/unlocking files.  This usually happens around the change to/from
  123.  daylight savings time.  See "Server and workstation clock times" in the Appleshare
  124.  questions and answers in Apple Tech note NW 515 for more information on this.
  125.  
  126.  Kludge comments:
  127.  Because a person on a server machine cannot mount their own machine
  128.  I have a bunch of special case code that allows one to use this software
  129.  on a server machine.  
  130.  (thus the need for *server-name* & *folder-of-server-volume-on-server*)
  131.  
  132.  Changes you have to make:
  133.    The only changes you should need to make for your project are to the defparameters below.
  134. |#
  135.  
  136. ;;; ------------------------------------------------------------------------------------------------
  137. ;;; Change the following defparameters for your project.
  138.  
  139. ;(defparameter *server-volume* "Data Storage - AK Lab:MJC backup:MOPED Server:")
  140. (defparameter *server-volume* "SC-builder:test:")
  141.          ;Server folder where the project files are kept.  The first part of it is what users
  142.          ;connect to (i.e. it is the shared folder).
  143.          ;e.g. sc-builder:test: -- users connect to folder sc-builder
  144.          ;I recommend that users create an alias with this name on their desktop so that
  145.          ;the server-volume is automatically opened when rcs is initialized.
  146.         
  147. ;(defparameter *home-directory-o* "ccl:MOPED;")       
  148. (defparameter *home-directory-o* "ccl:SC-builder;")       
  149.                 ;Local home directory where the project files are kept for all users.
  150.                 ;This is where a file ends up when locked and copied to the users hard disk.
  151.                 ;It must be understood by all user machines so it is recommended it be put under 
  152.                 ;ccl: or home:.  Or it can also be set in rcs-init.lisp.
  153.                 ;[[Note use of CL style logical pathname (page 628 of Steele)
  154.                 ;with semicolin separating directories.]]
  155.                 ;e.g. ccl:myproject;
  156.  
  157. ;;; The following two defparamters need to be set if a user is going to be using the server machine.
  158. ;(defparameter *server-name* "Chung's Macintosh")
  159. (defparameter *server-name* "neves")  
  160.     ;If nobody is using the server machine then you don't need to set this.
  161.     ;This is the name of the machine that is the server -- the Macintosh name
  162.     ;in sharing setup.
  163.     ;e.g. "neves"
  164.  
  165.  
  166. ;(defparameter *folder-of-server-volume-on-server* "MJC backup:")
  167. (defparameter *folder-of-server-volume-on-server* "hd:applications:")
  168.          ;Used only by the person using the server machine.  If nobody is using the
  169.          ;server machine then you don't need to set this.
  170.          ;This is the folder on the server that contains the *server-volume*.
  171.          ;e.g. hd:applications:
  172.          ;so the path to the directory users will copy from is hd:applications:sc-builder:test:
  173.  
  174. ;;; The following two defparameters need to be set if you want backups saved of the files that
  175. ;;; someone unlocks.
  176. (defparameter *rcs-backup-folder* "SC-builder:test:backups:")
  177.                                       ;if non nil then use as a location for a backup folder
  178.                                       ;to save older versions of unlocked files.
  179.                                       ;This name is also automatically placed on *files-not-to-copy*
  180. (defparameter *rcs-backup-versions* 2) ;use nil for unlimited. 2, keep last 2 versions
  181.  
  182.  
  183. ;;; The following names do not need to be changed.      
  184. (defparameter *filename-locked-file-list-file* "locked-file-list") 
  185.                     ;File for list of locked files
  186. (defparameter *filename-log-file* "logfile")    
  187.                     ;File for documentation on changes made to files
  188. (defparameter *filename-lock-name* "!for locking protocol!") 
  189.                     ;name of temporary file used to control
  190.                     ;who currently has access to locking/unlocking
  191. (defparameter *rcs-init-file-name* "ccl:rcs-init.lisp"); name of init file
  192.  
  193. ;;; -----------------------------------------------------------------------------------------
  194. ;;; More optional defvars to set. Can be set in rcs-init.lisp or this file.
  195. (defvar *files-not-to-copy* nil) ; list of files or directories not to update to local disk from server
  196. (defvar *files-to-copy* nil)     ; list of files or directories to update to local disk.  (see doc below)
  197. (defvar *rcs-project-list* nil)  ; list of projects you are working on. see doc below
  198. (defvar *current-project* nil)   ; current project working on.
  199.  
  200. ;;; -----------------------------------------------------------------------------------------
  201. ;;;;; Internally set defvars
  202. (defvar *locked-file-list-file*) ; full pathname of locked-file-list-file
  203. (defvar *log-file*)              ; full pathname of log file
  204. (defvar *home-directory*)        ; set from home-directory-o above
  205. (defvar *expanded-server-volume*); expanded version of server-volume
  206. (defvar *locked-file-list*)      ; temporary list holding the contents of locked-file-list-file
  207. (defvar *last-directory-locked* nil) ;most recent server directory accessed from lock-project-file.
  208. (defvar *rcs-menu*)              ; lock file menu
  209. (defvar *lock-name*)             ; controlling file to prevent multiple people from locking
  210.                                  ; at the same time.  expanded version of *filename-lock-name*
  211. (defvar *lock-id* nil)               ; id of open lock to be closed later
  212. (defparameter *max-lock-wait-time* 10) ; max number of seconds to wait for a lock/unlock
  213. ;;; -----------------------------------------------------------------------------------------
  214. #|
  215.  Files-not-to-copy and files-to-copy
  216. Normally all files are copied from the source disk to the destination disk.  The user can change
  217. this by specifying files or directories to copy or not to copy.  Examples:
  218. specify a parent directory to copy and a child directory not to copy 
  219. or
  220. specify a parent directory to not copy and a child directory to copy
  221. You can set these lists in rcs-init.lisp if you like.  Each directory or file should
  222. be a string.
  223. e.g.
  224. (setq *files-not-to-copy* '("server:proj-backup:")) ;don't copy directory proj-backup
  225. (setq *files-to-copy* '("server:proj-backup:picts:")) ;however do copy the picts
  226.  
  227. --------------------------------- Project stuff
  228. *rcs-project-list* is a list of projects.  This allows the user to switch between projects
  229. so that he or she can lock/unlock files in those projects.
  230. *current-project* is the current project that the user is accessing.
  231.  
  232. Example code to put in rcs-init.lisp or in this file
  233. ;;; (name-of-project server-name home-directory server-volume folder-of-server-volume backup-folder backup-versions)
  234. (setq *rcs-project-list*
  235.       '(
  236.         ("project1" "neves" "ccl:sc-builder;" "sc-builder:" "hd:applications:")
  237.         ("project2" "neves" nil "foo:" "hd:fee:") ))
  238.         ;nil default in project2 set by loading rcs-init.lisp in (init-rcs)
  239.         ;e.g. (in rcs-init.lisp)
  240.         ;(when (equal *current-project* "project2")
  241.         ;   (setq *home-directory-o* "hd:baz;"))
  242. (when (null *current-project*) (setq *current-project* "project1"))
  243.  
  244. |#
  245. ;;; -----------------------------------------------------------------------------------------
  246. (defun on-server-p nil (string-equal (machine-instance) *server-name*))
  247.  
  248. (defmacro concat (&rest strings)
  249.   `(concatenate 'string ,@strings))
  250.  
  251. (defun check-server-p nil
  252.    (if (null (probe-file *expanded-server-volume*))
  253.      (progn
  254.        (message-dialog (concat "RCS Error, Could not find server " *server-volume* ". -- Aborting."))
  255.        nil)
  256.      t))
  257.  
  258. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  259. ;;; Locking protocol stuff
  260.  
  261. ;;; returns t if successful and nil if not successful
  262. ;;; Use file write locking on server to make sure only one person at a time can make changes to 
  263. ;;; the master file of locked files.
  264. (defun set-lock ()
  265.   (let (time)
  266. ;    (when *lock-id* (return-from set-lock nil))
  267.     (setq time (get-universal-time))
  268.     (loop
  269.       (setq *lock-id*
  270.             (handler-case (open *lock-name* :direction :output :if-exists :supersede)
  271.               (file-error () nil)))
  272.       (when *lock-id* (return *lock-id*))
  273.       (when (and (> (- (get-universal-time) time) *max-lock-wait-time*)
  274.                (prog1 
  275.                  (not (y-or-n-dialog (concat "I have waited longer than " 
  276.                                              (prin1-to-string *max-lock-wait-time* )
  277.                                              " seconds to get a lock.  Should I wait longer?")
  278.                                      :cancel-text nil))
  279.                  (setq time (get-universal-time))))
  280.         (return nil)))))
  281.         
  282. (defun destroy-lock ()
  283.   (if *lock-id* (close *lock-id*)
  284.       ;; just in case some fool (like me) calls set-lock outside of a with-transaction
  285.       ;; and forgets to close it
  286.       (dolist (s *open-file-streams*)
  287.         (when (string-equal (namestring (stream-filename s)) *lock-name*)
  288.           (close s))))
  289.   (setq *lock-id* nil)
  290.   )
  291.  
  292. ;;; Locking should be done with this macro so that destroy-lock is always done.
  293. (defmacro with-transaction (&body body)
  294.      `(unwind-protect (if (set-lock) (progn ,@body))
  295.         (without-interrupts (destroy-lock)))) ; make sure destroy-lock gets to finish
  296.  
  297. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  298. ;       Support for multiple projects
  299. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  300.  
  301. (defun get-project (project)
  302.   (assoc project *rcs-project-list* :test #'string-equal))
  303.  
  304. (defun register-project (info-list)
  305.   "register a project with RCS.  
  306. info-list is (name-of-project server-name home-directory server-volume folder-of-server-volume 
  307. backup-folder backup-versions)"
  308.   (setq *rcs-project-list* (delete info-list *rcs-project-list* 
  309.                                    :test #'(lambda (x y) (string= (car x) (car y)))))
  310.   (push info-list *rcs-project-list* ))
  311.  
  312. (defun change-project (project &optional (init t))
  313.   (let* ((list (get-project project))
  314.          (project-name (first list))
  315.          (server-name (second list))
  316.          (home-dir (third list))
  317.          (server-volume (fourth list))
  318.          (folder-on-server (fifth list))
  319.          (backup-folder (sixth list))
  320.          (backup-versions (seventh list)))
  321.  
  322.     (setq *last-directory-locked* nil)
  323.     (setq *current-project* project-name)
  324.     (setq *server-name* server-name)
  325.     (setq *home-directory-o* home-dir)
  326.     (setq *server-volume* server-volume)
  327.     (setq *folder-of-server-volume-on-server* folder-on-server)
  328.     (setq *rcs-backup-folder* backup-folder)
  329.     (setq *rcs-backup-versions* backup-versions)
  330.     (when init (init-rcs))
  331.     ))
  332. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  333.  
  334. ;;; (expand-host "ccl:foo:bar") --> "HD:MCL 2.0:foo:bar"
  335. ;;;  Note that ccl:foo:bar is not a legal logical pathname (no semicolons between directories)
  336. (defun expand-host (path)
  337.   (let ((pos (search ":" path))
  338.         hostname rest)
  339.     (when (null pos) (error "no host for expand-host"))
  340.     (setq hostname (subseq path 0 (1+ pos)))
  341.     (setq rest (subseq path (1+ pos)))
  342.     (concat (namestring (translate-logical-pathname hostname)) rest)))
  343.  
  344. (defun get-host (path)
  345.   (subseq path 0 (1+ (search ":" path))))
  346.                     
  347. ;;; init-rcs is called automatically at the end of this file
  348. (defun init-rcs nil
  349.   (when (probe-file *rcs-init-file-name*) (load *rcs-init-file-name*))
  350.   (let (server-servers-volume host-server-volume change-project-menu-item)
  351.     (setq host-server-volume (get-host *server-volume*))
  352.     (if (search ";" *home-directory-o*)
  353.       (setq *home-directory* (namestring (translate-logical-pathname *home-directory-o*)))
  354.       (setq *home-directory* (expand-host *home-directory-o*))) ;non legal pathname.  expand host.
  355.     (setq *expanded-server-volume* *server-volume*)
  356.     (when (on-server-p)
  357.       (setq server-servers-volume (concat (expand-host *folder-of-server-volume-on-server*)
  358.                                            (get-host *server-volume*)))
  359.       (setf (logical-pathname-translations 
  360.              ;; take out the colon at the end of *server-volume*
  361.              (subseq host-server-volume 0 (1- (length host-server-volume))))
  362.             ;; copied right out of steele without understanding it...
  363.             `(("**;*.*.*" ,(concat server-servers-volume "**"))))
  364.       (setq *expanded-server-volume* (expand-host *server-volume*))
  365.       )
  366.     (when (null (check-server-p)) (return-from init-rcs))
  367. ;;; check to see if the following two statements do the right thing ZZZ
  368.     (setq *locked-file-list-file* (concat *server-volume* *filename-locked-file-list-file*))
  369.     (setq *log-file* (concat *server-volume* *filename-log-file*))
  370.     (setq *lock-name* (concat *expanded-server-volume* *filename-lock-name*))
  371.     (pushnew *locked-file-list-file* *files-not-to-copy* :test #'string-equal)
  372.     (when *rcs-backup-folder*
  373.       (pushnew *rcs-backup-folder* *files-not-to-copy* :test #'string-equal))
  374.     (pushnew (concat *server-volume* *filename-lock-name*) *files-not-to-copy* :test #'string-equal)
  375.     (pushnew  *log-file* *files-not-to-copy* :test #'string-equal)
  376.     (if (find-menu "LockFile") (menu-deinstall *rcs-menu*))
  377.     (setq *rcs-menu* (make-instance 'menu :menu-title "LockFile"))
  378.     (add-menu-items *rcs-menu*
  379.                    (make-instance 'menu-item
  380.                           :menu-item-title "Lock    - (a project file and copy to local disk)"
  381.                           :menu-item-action 'lock-project-file
  382.                           :help-spec 
  383.                           (format nil "Lock a file.  This brings up a dialog so that the ~
  384.                                        user can choose a file to lock. If the file is ~
  385.                                        already locked then the user gets an error message.  ~
  386.                                        Locking a file copies the file from the server to ~
  387.                                        the local hard disk."))
  388.                    (make-instance 'menu-item
  389.                           :menu-item-title "Unlock - (a project file and copy back to server)"
  390.                           :menu-item-action 'unlock-project-file
  391.                           :help-spec
  392.                           (format nil "Unlock a file and copy to server.  This brings up ~
  393.                                        a dialog with all your locked files. Select 1 or ~
  394.                                        more files (with shift-click) to unlock.  The ~
  395.                                        files are copied back to the  server."))
  396.                    (make-instance 'menu-item
  397.                           :menu-item-title "Forget - (Unlock project file but don't copy new version to server)"
  398.                           :menu-item-action 'unlock-file-dont-copy
  399.                           :help-spec 
  400.                           (format nil "Unlock a file, but don't copy to server.  This is ~
  401.                                        like 'Unlock' but the files are not copied to ~
  402.                                        the server. Useful when the user changes his/her ~
  403.                                        mind about making the changes permanent."))
  404.                    (make-instance 'menu-item
  405.                           :menu-item-title "Copy    - (newly created file to server.)"
  406.                           :menu-item-action 'copy-new-file-to-server
  407.                           :help-spec
  408.                           (format nil "Copy a newly created file to the server. The user ~
  409.                                        has just created a file on his/her hard disk.  ~
  410.                                        To move it to the server choose this."))
  411. ;                   (make-instance 'menu-item
  412. ;                          :menu-item-title "Copy logged files to local disk."
  413. ;                          :menu-item-action 'copy-logfiles-to-local-disk)
  414.                    (make-instance 'menu-item
  415.                           :menu-item-title "Update - (files on local disk)"
  416.                           :menu-item-action #'(lambda nil (eval-enqueue
  417.                                                            '(copy-directory-1 *expanded-server-volume* *home-directory*)))
  418.                           :help-spec
  419.                           (format nil "Copy server directory to local disk.  ~
  420.                                        Updates all files on local disk."))
  421.                    (make-instance 'menu-item
  422.                           :menu-item-title "Show locked  - (all locked files)"
  423.                           :menu-item-action 'find-all-locked-files
  424.                           :help-spec 
  425.                           (format nil "Show a list of all the locked files, ~
  426.                                        along with who locked them."))
  427.                    (make-instance 'menu-item
  428.                           :menu-item-title "Show changes   - (made to project files)"
  429.                           :menu-item-action 'show-log-file
  430.                           :help-spec 
  431.                           (format nil "Show a list of past changes to all files."))
  432.                    (make-instance 'menu-item
  433.                           :menu-item-title "Show file comments   - (for this file)"
  434.                           :menu-item-action 'show-log-for-top-window
  435.                           :help-spec 
  436.                           (format nil "Show a list of past changes for topmost file."))
  437.                    (make-instance 'menu-item
  438.                           :menu-item-title "Help"
  439.                           :menu-item-action 'show-help)
  440.                    )
  441.  
  442.     (when *rcs-project-list*
  443.       (add-menu-items *rcs-menu*
  444.                       (setq change-project-menu-item
  445.                       (make-instance 'menu-item
  446.                         :menu-item-title (format nil "Change Project from ~a" *current-project*)
  447.                         :menu-item-action
  448.                         #'(lambda nil
  449.                             (let (result)
  450.                               (setq result 
  451.                                     (catch-cancel 
  452.                                       (select-item-from-list 
  453.                                        (mapcar #'car
  454.                                                (remove *current-project* *rcs-project-list*
  455.                                                        :test #'(lambda (x y) (equal x (car y)))))
  456.                                        :window-title "Select new project"
  457.                                                )))
  458.                               (when (neq result :cancel)
  459.                                 (eval-enqueue `(progn (change-project ,(car result))
  460.                                                       (set-menu-item-title ,change-project-menu-item
  461.                                                                            (format nil "Change Project from ~a" ,(car result))))))))
  462.                         :help-spec
  463.                         (format nil "Switch to a different project.")
  464.                         ))))
  465.  
  466.             
  467.   (menu-install *rcs-menu*)
  468.   
  469.   (load-locked-file-list)
  470.  
  471.   (unless (member 'init-rcs *lisp-startup-functions*)
  472.     (setf *lisp-startup-functions*
  473.           (nconc *lisp-startup-functions* (list 'init-rcs))))
  474.   
  475.   
  476.   ))
  477.  
  478.  
  479. ;;; ================================================================================
  480. ;;; Backup stuff
  481. ;;; Backup files are kept in a file structure in *rcs-backup-folder*.  The leaf nodes in
  482. ;;; this structure are a little different than what is one the server.  Server file names
  483. ;;; are a folder name on the backup folder and versions of that file are numbered files
  484. ;;; within that folder.
  485. ;;; e.g.
  486. ;;; server:baz:biz.lisp on the server could have the following backups
  487. ;;; backup:baz:biz.lisp:1
  488. ;;; backup:baz:biz.lisp:2
  489. ;;; backup:baz:biz.lisp:3
  490. ;;; backup:baz:biz.lisp:4
  491. (defun server-to-backup-folder-name (serverfile)
  492.   (let ((name (file-namestring serverfile))
  493.         (stripped (strip-left *expanded-server-volume* (directory-namestring serverfile))))
  494.     (concat (expand-host *rcs-backup-folder*)
  495.             stripped
  496.             name
  497.             ":"
  498.             )))
  499.  
  500. (defun backup-server-file (serverfile)
  501.   (when *rcs-backup-folder*
  502.     (let* ((backup-folder (server-to-backup-folder-name serverfile))
  503.            (backups (mapcar #'(lambda (x) (read-from-string (file-namestring x)))
  504.                             (directory (concat backup-folder "*"))))
  505.            (last-num (or (and backups (apply #'max backups)) 0))
  506.            first-num
  507.            )
  508.       (when (probe-file serverfile)
  509.         (copy-file serverfile (concat backup-folder (prin1-to-string (1+ last-num)) "."))
  510.         (when (numberp *rcs-backup-versions*)
  511.           (dotimes (i (- (1+ (length backups)) *rcs-backup-versions*))
  512.             (setq first-num (apply #'min backups))
  513.             (delete-file (concat backup-folder (prin1-to-string first-num) "."))
  514.             (setq backups (delete first-num backups))))))))
  515.  
  516. ;;; ================================================================================
  517.  
  518. (defun server-to-logical-server-name (file)
  519.   (concat *server-volume*
  520.           (strip-left *expanded-server-volume* file)))
  521.  
  522. ;;; lock a file
  523. (defun lock-project-file nil
  524.   (let (fromserverfile from-logical-server-file
  525.         tofile
  526.         tofileyounger
  527.         within
  528.         (server-volume *expanded-server-volume*)
  529.         (default-choose-directory (choose-file-default-directory))
  530.         )
  531.     (when (string-equal (machine-instance) "")
  532.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  533.       (return-from lock-project-file))
  534.     (when (null (check-server-p)) (return-from lock-project-file))
  535.     (setq fromserverfile 
  536.           (catch-cancel 
  537.             (choose-file-dialog :directory (if *last-directory-locked* *last-directory-locked* 
  538.                                                *expanded-server-volume*)
  539.                                 :button-string "Lock file"
  540.                                 )))
  541.     (set-choose-file-default-directory default-choose-directory)
  542.     (when (neq fromserverfile :cancel)
  543.       (setq fromserverfile (namestring fromserverfile))
  544.       (setq within (search server-volume fromserverfile :test #'string-equal))
  545.       (when (or (null within) (not (zerop within)))
  546.         (message-dialog 
  547.          (concat "File to be locked was not contained within the server: " server-volume " -- Aborting command."))
  548.         (return-from lock-project-file))
  549.       (setq *last-directory-locked* (directory-namestring fromserverfile))
  550.       (setq from-logical-server-file (server-to-logical-server-name fromserverfile))
  551.       (with-transaction
  552.         (when (is-locked-filep from-logical-server-file)
  553.           (destroy-lock) ;; just in case someone takes too long in the message-dialog below
  554.           (message-dialog (concat from-logical-server-file " is already locked.  Aborting command."))
  555.           (return-from lock-project-file))
  556.         (setq tofile (logicalserver-to-home-name from-logical-server-file))
  557.         (setq tofileyounger (is-youngerp tofile fromserverfile))
  558.         (when (or (not tofileyounger)
  559.                   (and tofileyounger
  560.                                            ;; hopefully not much time will be spent in this dialog
  561.                                            ;; because the lock is set in with-transaction
  562.                        (eq t (catch-cancel (y-or-n-dialog
  563.                                             "WARNING!  The file on the local disk is younger than the one on the server.  Should I still copy it and so delete your version?")))))
  564.           (if (probe-file tofile) (unlock-file tofile))
  565.           (update-locked-file-list from-logical-server-file :add)
  566.           (destroy-lock) ;;kind of ugly, but it should be done here
  567.           (when (null (is-same-age fromserverfile tofile))
  568.             (copy-file fromserverfile tofile
  569.                        :if-exists :supersede))
  570.           (let ((window (my-find-window tofile)))
  571.             (when window (window-close window))) 
  572.           (when
  573.             (and (eq (mac-file-type tofile) :TEXT)
  574.                  (y-or-n-dialog  
  575.                   (concat fromserverfile " has been copied to your disk and is locked.  To edit the file click on EDIT, otherwise click on OK.")
  576.                   :yes-text "EDIT" :no-text "OK" :cancel-text nil))
  577.             (ed tofile))
  578.        )))))
  579.  
  580. (defun my-find-window (name)
  581.   (setq name (pathname name))
  582.   (dolist (w (windows) nil)
  583.     (when (equal name (window-filename w)) (return w))))
  584.  
  585. (defun is-youngerp (file1 file2)
  586.   (and (probe-file file1) (probe-file file2) (> (file-write-date file1) (file-write-date file2))))
  587.  
  588. (defun is-same-age (file1 file2)
  589.   (and (probe-file file1) (probe-file file2) (eql (file-write-date file1) (file-write-date file2))))
  590.  
  591. ;;; format of locked-file-list is ((filename . person) (filename . person) ...)
  592.  
  593. (defun is-locked-filep (filename)
  594.   (load-locked-file-list)
  595.   (assoc filename *locked-file-list* 
  596.          :test #'string-equal))
  597.  
  598. (defun load-locked-file-list nil
  599.   (let ((expanded (expand-host *locked-file-list-file*)))
  600.     (if (null (probe-file expanded))
  601.       (with-open-file (stream expanded :direction :output)
  602.         (print nil stream)))
  603.     (setq *locked-file-list*
  604.           (with-open-file  (stream expanded :direction :input)
  605.             (read stream)))))
  606.  
  607. (defun save-locked-file-list nil
  608.   (let* ((expanded (expand-host *locked-file-list-file*))
  609.          (tempfilename (concat expanded "temp")))
  610.     (with-open-file (stream tempfilename :direction :output :if-exists :supersede)
  611.       (print *locked-file-list* stream))
  612.     (rename-file tempfilename expanded :if-exists :supersede)))
  613.  
  614. (defun username nil (machine-instance))
  615.  
  616. (defun make-pair (&key filename person)
  617.   (cons filename person))
  618. (defun get-person (pair)
  619.   (rest pair))
  620. (defun get-filename (pair)
  621.   (first pair))
  622.  
  623. ;;; ------------------------------------------------------------------------------------
  624. ;;; unlock a file
  625. (defun unlock-project-file (&optional (dontcopyflag nil))
  626.    (let ((username (machine-instance))
  627.          (homefilename)
  628.          (serverfilenames))
  629.     (when (eql username "")
  630.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  631.       (return-from unlock-project-file))
  632.     (when (null (check-server-p)) (return-from unlock-project-file))
  633.      (setq serverfilenames 
  634.            (catch-cancel 
  635.             (select-item-from-list (find-my-locked-files) :selection-type :disjoint
  636.                                    :default-button-text 
  637.                                    (if dontcopyflag "Forget" "Unlock"))))
  638.      (when (neq serverfilenames :cancel)
  639.       (dolist (serverfilename serverfilenames)
  640.         ;; doncopyflag means unlock the file but don't copy your version to the project directory
  641.         (setq homefilename (logicalserver-to-home-name serverfilename)) 
  642.         (when (null dontcopyflag)
  643.           (if (probe-file homefilename)  
  644.             (copy-to-server-and-update-logfile homefilename serverfilename 
  645.                                                (expand-host serverfilename))
  646.             (format t "You do not have ~a to copy to the project directory~%" homefilename))
  647.         )
  648.      ;;   (let ((window (find-window (pathname-name homefilename))))
  649.      ;;     (when window (window-close window)))         JL--closing the homefile window, if its here
  650.      ;;   (lock-file homefilename)   JL--locking the homefile
  651.  
  652.         ;; bug. if a lock cannot be gotten then the locked file list will not be updated.  Yet
  653.         ;; the log file will be updated and the new file will be on the server.
  654.         (with-transaction
  655.           (update-locked-file-list serverfilename :delete))
  656.         ))))
  657.  
  658. ;;; Given a name on the server, construct the corresponding name on the home directory.
  659. (defun logicalserver-to-home-name (filename)
  660.   (concat *home-directory* 
  661.           (strip-left *server-volume* (namestring filename))))
  662.  
  663. ;;; Given a name on the home directory, construct a name for the server
  664. (defun home-to-server-name (filename) 
  665.   (concat *server-volume*
  666.           (strip-left *home-directory*  (namestring filename))))
  667.  
  668. (defun copy-to-server-and-update-logfile (homefilename serverfilename expandedserverfilename)
  669.   (when (or (null (probe-file expandedserverfilename))
  670.           (>= (file-write-date homefilename) (file-write-date expandedserverfilename))
  671.           (eq t (catch-cancel (y-or-n-dialog
  672.                                "WARNING!  The file on the local disk is older than the one on the server.  Should I still copy it?"))))
  673.     (when (probe-file expandedserverfilename)
  674.       (unlock-file expandedserverfilename))     ;;JL--unlock the serverfile if it's there
  675.     (backup-server-file expandedserverfilename)
  676.     (copy-file homefilename expandedserverfilename :if-exists :supersede)
  677.     (lock-file (expand-host serverfilename))  ;so user doesn't accidently edit it
  678.    ;; (let ((window (find-window (pathname-name homefilename))))
  679.    ;;   (when window (window-close window)))   JL--close the homefile window if its there
  680.    ;; (lock-file homefilename)      JL--lock the homefile (now that window is closed
  681.       ;; make sure the dates on both files are the same in case clocks are off on
  682.       ;; both machines. 
  683.     (set-file-write-date homefilename (file-write-date expandedserverfilename))
  684.     (update-log-file serverfilename)
  685.       ))
  686.  
  687. (defun copy-new-file-to-server nil
  688.   (let (homefilename serverfilename expandedserverfilename within)
  689.     (message-dialog "Please select a newly created file to copy to the server.")
  690.     (setq homefilename 
  691.           (catch-cancel (choose-file-dialog :directory *home-directory*
  692.                                 )))
  693.     (when (neq homefilename :cancel)
  694.       (setq homefilename (namestring homefilename))
  695.       (setq within (search *home-directory* homefilename :test #'string-equal))
  696.       (when (or (null within) (not (zerop within)))
  697.         (message-dialog 
  698.          (concat "New file was not contained within " *home-directory* " -- Aborting command."))
  699.         (return-from copy-new-file-to-server))
  700.       (setq serverfilename (home-to-server-name homefilename))
  701.       (setq expandedserverfilename (expand-host serverfilename))
  702.       (when (probe-file expandedserverfilename)
  703.         (message-dialog (concat serverfilename " already exists.  Aborting command."))
  704.         (return-from copy-new-file-to-server))
  705.       (copy-to-server-and-update-logfile homefilename serverfilename expandedserverfilename)
  706.       )))
  707.     
  708. (defun update-locked-file-list (file operation)
  709.   (load-locked-file-list)
  710.   (let ((newpair (make-pair :filename file :person (username))))
  711.     (cond
  712.      ((eq operation :add) 
  713.       (pushnew newpair *locked-file-list*))
  714.    ((eq operation :delete) 
  715.     (setq *locked-file-list* 
  716.           (delete newpair *locked-file-list* :test #'equal)))
  717.    (t (error "illegal operation in update-locked-file-list")))
  718.   (save-locked-file-list)))
  719.  
  720. ;(defun modeless-get-string-from-user (message &rest x)
  721. ;  (let (dialog finishedflag)
  722. ;    (setq dialog
  723. ;          (apply #'get-string-from-user message 
  724. ;                 :modeless t
  725. ;                 :action-function #'(lambda (string) (setq finishedflag string))
  726. ;                 x))
  727. ;    (loop (dotimes (i 10) (event-dispatch)) (when (or (null (wptr dialog)) finishedflag) (window-close dialog) (return finishedflag)))
  728. ;    ))
  729.  
  730. (defun update-log-file (filename)
  731.   (setq filename (namestring filename))
  732.   (let ((changes))
  733.     (with-open-file (stream (expand-host *log-file*) :direction :output :if-exists :append :if-does-not-exist :create)
  734.       (setq changes (catch-cancel ;catch-cancel & cancel-text are not needed for modeless-get...
  735.                      (get-string-from-user (concat "File " filename " has been copied to the server.  Describe your changes to the file here.")
  736.                                            :cancel-text "No msg")))
  737.       (format stream "~a \"~a\" ~a -- ~a~%" (machine-instance) filename (return-the-date) changes)
  738.       )))
  739.  
  740. (defun return-the-date nil
  741.   (multiple-value-bind  (second minute hour date month year 
  742.                                 day-of-week daylight-saving-timep time-zone)                        
  743.                         (get-decoded-time)
  744.     (declare (ignore second year day-of-week daylight-saving-timep time-zone))
  745.     (format nil "(~a:~2,'0d ~a/~2,'0d)" hour minute month date)))
  746.   
  747. (defun find-my-locked-files nil
  748.   (find-user-locked-files (username)))
  749.  
  750. (defun find-user-locked-files (user)
  751.   (mapcar 'get-filename
  752.           (remove user *locked-file-list* 
  753.                   :test #'(lambda (user y) (not (equal user (get-person y)))))))
  754.       
  755. (defun find-people-with-locked-files nil
  756.   (let (people)
  757.     (dolist (pair *locked-file-list*)
  758.       (pushnew (get-person pair) people :test #'equal))
  759.     people))
  760.  
  761. (defun find-all-locked-files nil
  762.   (load-locked-file-list)
  763.   (show-listener)
  764.   (format t "~%--Locked file list--~%")
  765.   (if (null *locked-file-list*) (format t "There are no locked files.")
  766.       (dolist (person (find-people-with-locked-files))
  767.         (format t "Locked files for ~a:~%" person)
  768.         (dolist (file (find-user-locked-files person))
  769.           (format t "   ~a~%" file)))))
  770.  
  771. (defun show-listener nil
  772.   (window-select (find-window "Listener")))
  773.  
  774. (defun unlock-file-dont-copy nil
  775.   (unlock-project-file t))
  776.  
  777. ;;; copy a file and make sure the write dates are the same on both files
  778. (defun copy-file-and-set-write-date (fromfile tofile)
  779.   (copy-file fromfile tofile :if-exists :supersede)
  780.   (set-file-write-date tofile (file-write-date fromfile)))
  781.  
  782. ;;;-----
  783. ;;; Copy files from logfile to local disk.  Remove duplicate names in logfile list of files.
  784. ;;; BUGS: doesn't check to see if local files are more recent than server files.
  785. ;;; This function is currently not being used and has bugs since it hasn't been updated.
  786. #|
  787. (defun copy-logfiles-to-local-disk nil
  788.     (let (linelist selectlist tofile fromfilelist)
  789.       (with-open-file  (finput *log-file* :direction :input)
  790.         (setq linelist
  791.               (do* ((line (read-line finput nil :eof)(read-line finput nil :eof))
  792.                     (linelist)
  793.                     (pos))
  794.                    ((eq line :eof) linelist)
  795.                 (setq pos (position #\" line)) ;kludge for testing for a filename in line
  796.                 (if pos
  797.                   (push line linelist)))))
  798.       (setq selectlist
  799.             (catch-cancel 
  800.               (select-item-from-list linelist :selection-type :disjoint)))
  801.       (when (and selectlist (not (eq selectlist :cancel)))
  802.         (show-listener)
  803.         (setq fromfilelist
  804.               (mapcar #'(lambda (line) (read-from-string line nil nil :start (position #\" line)))
  805.                       selectlist))
  806.         (setq fromfilelist (remove-duplicates fromfilelist :test #'string-equal))
  807.         (dolist (fromfile fromfilelist)
  808.           (if (probe-file fromfile)
  809.             (progn
  810.               (setq tofile (server-to-home-name fromfile))
  811.               (format t "~%About to copy file ~a to ~a -- " fromfile tofile)
  812.               (copy-file-and-set-write-date fromfile tofile)
  813.               (format t "DONE"))
  814.             (format t "~%Did not copy file ~a because I could not find it." fromfile))))))
  815.     
  816. |#
  817.  
  818. (defun rcs-directoryp (string)
  819.   (eql #\: (char string (1- (length string)))))
  820.  
  821. (defun copy-directory-1 (from to)
  822.   (let
  823.     ((stream (make-instance 'fred-window
  824.                            :window-title "Update Log"
  825.                            :scratch-p t))
  826.      (copyflag (if (member from *files-not-to-copy* :test #'string-equal)
  827.                  nil t)))
  828.     (format stream "~%About to copy ~s to ~s ~%" from to)
  829.     (select-directories-to-not-copy)
  830.     (copy-directory from to t nil stream copyflag)
  831.     (format stream "~%DONE!~%")
  832.     (fred-update stream)
  833.     ))
  834.  
  835. (defun directories-in-files-dont-copy ()
  836.   (let (result)
  837.     (dolist (item *files-not-to-copy*)
  838.       (when (rcs-directoryp item) (push item result)))
  839.     result))
  840.  
  841. (defmethod my-set-table-sequence ((item sequence-dialog-item) new-seq)
  842.   (set-table-sequence item new-seq)
  843.   (set-cell-size item
  844.               (default-cell-size item))
  845.   (set-visible-dimensions item (table-dimensions item)))
  846.  
  847. (defun add-a-directory (dialog-item)
  848.   (let (result within thesequenceitem)
  849.     (setq result (catch-cancel (choose-directory-dialog :directory *expanded-server-volume*)))
  850.     (when (not (eq result :cancel))
  851.       (setq result (namestring result))
  852.       (setq within (search *expanded-server-volume* result :test #'string-equal))
  853.       (if (or (null within) (not (zerop within)))
  854.         (message-dialog 
  855.          (concat "Directory was not contained within the server: " *expanded-server-volume* " -- Aborting command."))
  856.         (pushnew (server-to-logical-server-name (namestring result)) *files-not-to-copy*
  857.                        :test #'string-equal))
  858.       (setq thesequenceitem (find-named-sibling dialog-item 'sequence))
  859.       (my-set-table-sequence thesequenceitem *files-not-to-copy*))))
  860.  
  861. (defun delete-a-file-or-directory (dialog-item)
  862.   (let (thesequenceitem cells)
  863.     (setq thesequenceitem (find-named-sibling dialog-item 'sequence))
  864.     (setq cells (selected-cells thesequenceitem))
  865.     (if (null cells) (message-dialog "Nothing was selected to delete")
  866.         (progn
  867.           (dolist (cell cells)
  868.             (setq *files-not-to-copy* 
  869.                   (delete (cell-contents thesequenceitem cell) *files-not-to-copy* 
  870.                           :test #'string-equal)))
  871.           (my-set-table-sequence thesequenceitem *files-not-to-copy*)))))
  872.  
  873. (defun select-directories-to-not-copy ()
  874.   (modal-dialog
  875.    (make-instance 'window :view-size #@(550 300) 
  876.                   :window-title "Select directories within the server to not copy."
  877.                   :view-subviews
  878.                   `(
  879.                     ,(make-instance 'static-text-dialog-item
  880.                        :dialog-item-text "List of Files/Directories not to copy"
  881.                        :view-position #@(10 0))
  882.                     ,(make-instance 'sequence-dialog-item
  883.                        :table-sequence *files-not-to-copy*
  884.                        :view-position #@(10 30)
  885.                        :view-nick-name 'sequence)
  886.                     ,(make-instance 'button-dialog-item
  887.                        :dialog-item-action #'delete-a-file-or-directory
  888.                        :dialog-item-text "Delete file/directory from list"
  889.                        :view-position #@(300 10))
  890.                     ,(make-instance 'button-dialog-item
  891.                        :dialog-item-action #'add-a-directory
  892.                        :dialog-item-text "Add directory to list"
  893.                        :view-position #@(300 35))
  894.                     ,(make-instance 'button-dialog-item
  895.                        :dialog-item-action #'(lambda (item) (window-close (view-window item)))
  896.                        :dialog-item-text "Done"
  897.                        :view-position #@(300 60))
  898.                     ,(make-instance 'static-text-dialog-item
  899.                        :dialog-item-text "FYI - List of Files/Directories to copy"
  900.                        :view-position #@(10 150))
  901.                     ,(make-instance 'sequence-dialog-item
  902.                        :table-sequence *files-to-copy*
  903.                        :view-position #@(10 180)
  904.                        :view-nick-name 'sequence2)
  905.  
  906.                     ))))
  907.  
  908. (defun dont-copyp (file-or-directory)
  909.   (member (server-to-logical-server-name file-or-directory) *files-not-to-copy* :test #'string-equal))
  910. (defun do-copyp (file-or-directory)
  911.   (member (server-to-logical-server-name file-or-directory) *files-to-copy* :test #'string-equal))
  912.  
  913. ;;; copy one directory to another directory
  914. ;;; verboseflag,if true, prints out a DOT when a file is read in
  915. ;;; purge, if true, deletes the destination directory
  916. (defun copy-directory (from to &optional (verboseflag t) (purge nil) (stream t) (copyflag t))
  917.   (setq from (namestring from)
  918.         to   (namestring to))
  919.   (unless (and (rcs-directoryp from) (probe-file from) (rcs-directoryp to) (not (equal from to)))
  920.     (cond
  921.      ((null (rcs-directoryp from)) (format stream "~s is not a directory name, aborted" from))
  922.      ((null (probe-file from)) (format stream "Could not find directory ~s, aborted" from))
  923.      ((null (rcs-directoryp to)) (format stream "~s is not a directory name, aborted" to))
  924.      ((equal from to) (format stream "~s, source and destination directories are the same, aborted")))
  925.     (return-from copy-directory))
  926. ;  (if (and copyflag (or purge (null (probe-file to)))) (create-file to :if-exists nil))
  927.   (dolist (fromfile (list-of-files from))
  928.     (let* ((filename (file-namestring fromfile))
  929.            (tofile (merge-pathnames to filename))
  930.            (tofilepresent (probe-file tofile))
  931.            (fromfilewritedate (file-write-date fromfile))
  932.            (tofilewritedate (and tofilepresent (file-write-date tofile))))
  933.       ;; if current directory is set up to copy check to see if file is excluded
  934.       ;; if current directory is set up not to copy check to see if file is included
  935.       (cond ((dont-copyp  (namestring fromfile)))
  936.             ((and (not copyflag) (not (do-copyp (namestring fromfile)))))
  937.             ((or (null tofilepresent) 
  938.                  (< tofilewritedate fromfilewritedate))
  939.              (if tofilepresent (unlock-file tofile))
  940.              (copy-file fromfile tofile :if-exists :supersede)
  941. ;             (lock-file tofile)
  942.              (when verboseflag (format stream "~%~a copied." fromfile))
  943.              ;; delete fasl file if copying over a .lisp file
  944.              (let ((fasl (convert-to-fasl tofile)))
  945.                (when (and fasl (probe-file fasl)) 
  946.                  (delete-file fasl)
  947.                  (when verboseflag (format stream "~%~a was deleted" (namestring fasl)))))
  948.              (set-file-write-date tofile fromfilewritedate)
  949.              (when (and verboseflag (typep stream 'fred-window)) (fred-update stream))
  950.              )
  951.             ((and tofilewritedate (> tofilewritedate fromfilewritedate))
  952.              (format stream "~%Your version of ~a is newer than the server's version so it was left untouched."
  953.                      tofile)))))
  954.   (dolist (dir (directory (concat from "*.*") :directories t :files nil)) ;mac specific
  955.     (let* ((newfromdir (directory-namestring dir))
  956.            (newpartdir (strip-left from newfromdir))
  957.            (newtodir (concat to newpartdir)))
  958.       (cond ((do-copyp newfromdir) (copy-directory newfromdir newtodir verboseflag purge stream t))
  959.             ((dont-copyp newfromdir) (copy-directory newfromdir newtodir verboseflag purge stream nil))
  960.             (t (copy-directory newfromdir newtodir verboseflag purge stream copyflag))
  961.             ))))
  962. ;      (when (not (dont-copyp newfromdir)) (copy-directory newfromdir newtodir verboseflag purge stream)))))
  963.  
  964. (defun convert-to-fasl (lispname)
  965.   (if (equal "lisp" (pathname-type lispname))
  966.     (make-pathname 
  967.      :host (pathname-host lispname)
  968.      :device (pathname-device lispname)
  969.      :directory (pathname-directory lispname)
  970.      :name (pathname-name lispname)
  971.      :type "fasl")
  972.     nil))
  973.       
  974. ;;; strip (length sub) characters from the left part of seq
  975. ;;; Used to strip off part of a directory from seq
  976. ;;; e.g. (strip-left "hd:" "hd:foo:") --> "foo:"
  977. (defun strip-left (sub seq)
  978.   (subseq seq (length sub)))
  979.  
  980. ;;; Return a list of files in directory "dir"
  981. (defun list-of-files (dir)
  982.   (directory (concat dir "*.*")))
  983.  
  984. (defun show-help ()
  985.  (message-dialog 
  986. "                    User choices from the lockfile menu:
  987.    - Lock a file.  This brings up a dialog so that the user can choose a 
  988.      file to lock.
  989.      If the file is already locked then the user gets an error message.  
  990.      Locking a file copies the file from the server to the local hard disk.
  991.  
  992.    - Unlock a file and copy to server.  This brings up a dialog with all 
  993.      your locked files.  
  994.      Select 1 or more files (with shift-click) to unlock.  
  995.      The files are copied back to the  server.
  996.  
  997.    - Forget. Unlock a file, but don't copy to server.  
  998.      This is like the choice above but the files are not copied to the server.  
  999.      Useful when the user changes his/her mind about making the 
  1000.      changes permanent.
  1001.  
  1002.    - Copy a newly created file to the server.  
  1003.      The user has just created a file on his/her hard disk.  
  1004.      To move it to the server choose this.
  1005.  
  1006.    - Update - copy server directory to local disk.  
  1007.      Updates all files on local disk.
  1008.  
  1009.    - Show all locked files.  
  1010.      Show a list of all the locked files, along with who locked them.
  1011.  
  1012.    - Show a list of past changes to files.
  1013.  
  1014.    -  File Comments
  1015.       Show a list of past comments on changes for topmost file.
  1016. "
  1017. :size (make-point *screen-width* (- *screen-height* 40))))
  1018.  
  1019. (defun show-log-file nil
  1020.   (let ((win (make-instance 'fred-window
  1021.                :window-title "RCS Change Log"
  1022.                :scratch-p t)))
  1023.     (buffer-insert-file (fred-display-start-mark win) 
  1024.                         (expand-host *log-file*))
  1025.     (fred-update win)))
  1026.  
  1027. (defun show-log-for-top-window nil
  1028.   (let (win filename fredwindow linelist)
  1029.     (setq win (first (windows)))
  1030.     (when (window-filename win)
  1031.       (setq filename (file-namestring (window-filename win)))
  1032.       (setq fredwindow (make-instance 'fred-window 
  1033.                        :window-title (concat "Comments of " filename)
  1034.                        :scratch-p t))
  1035.       (with-open-file  (finput (expand-host *log-file*) :direction :input)
  1036.         (do* ((line (read-line finput nil :eof)(read-line finput nil :eof)))
  1037.              ((eq line :eof))
  1038.           (push line linelist)))
  1039.       (dolist (line linelist)
  1040.         (when (search filename line :test #'string-equal) (princ line fredwindow) (terpri fredwindow)))
  1041.       (fred-update fredwindow))))
  1042.  
  1043. ;;; ------------------------------------------------------------------------------
  1044. (init-rcs)